perm filename WORDS.F4[NEW,LCS]8 blob
sn#322682 filedate 1977-12-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C WORDS, TYPE, SETLET, SETNUM , PRESCN
C00021 ENDMK
C⊗;
C WORDS, TYPE, SETLET, SETNUM , PRESCN
SUBROUTINE WORDS
INTEGER PWDS
COMMON R2,JA,RC,J2,R3,R4,R5,R6,R7,X,IA,N
1,Z,J,KN,ISET,KNT,Q(26),JR /PTR/PWDS(1)
1 /LIMIT/LIMIT,ITEM,LL,IS,IX
C /SCX/ IS ALSO IN SCMSS, NOTBMS, RHYTH, BEAMS, NEWR(IN LOOP.FAI)
C **** WHEN JALPHA IS EXTENDED FIX LOOP AT 365 AND SUBR. NEWR(IN LOOP)
C **** AND SUBR. SCMSS, NOTBMS, RHYTH AND BEAMS
COMMON/SCX/RHY(4),JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
1/XRN/RN(1) /ALF/INP(72),ML
COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
EQUIVALENCE (IBLA,JALPHA(12)),(INP2,INP(2))
DATA JALPHA/',','-','.','=','(',')','+','*',':',';'
1 ,'"',' ','$','%','&','@','#','<','>',1H','?','!'
1 ,"555004020100,"565004020100,"571004020100,"5004020100,
1 "135004020100,'/','[',']'/
C FOR ENTERING TEXT: T, POS., STF., NT#., SIZE, RHYTHM≠0
C NOT ANY LONGER****** R6 ≠0 CALLS NOTE NUM. SETUP
JR=-1
KNT=-1
C COUNTER FOR SEPARATE TEXT ITEMS.
CC IF(R3.NE.999)GO TO 131
IF(INP2.NE.LF)GO TO 131
C TYPE 'TF n,n,n,n' TO READ TYPEIN FROM A FILE.
TYPE 331
ACCEPT 631,KN
IF(LOOK(KN).EQ.0)RETURN
R2=R3
R3=R4
R4=R5
R5=R6
C 'TF' PUSHES PARAM LIST ONE NOTCH TO RIGHT.
C GO BACK IF NO FILE FOUND. READS ONLY FILES WITH LINE NUMBERS.
CALL IFILE(21,KN)
READ(21,431)JR,INP
JR=0
CC R6=1
GO TO 531
631 FORMAT(A5)
331 FORMAT(' TYPE FILE NAME-- '$)
431 FORMAT(I,72A1)
131 CALL TYPE
531 DO 31 KN=72,1,-1
31 IF(INP(KN).NE.IBLA)GO TO 33
C KN=NUM OF CHARACTERS
C DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
C , - . = ( ) + * : ; " BLANK (FONTS) ' --THIS IS ORDER PAST ALPHAB.
C [=QTR NOTE, ]=HALF NOTE, ↑=#, ↓=b, ↔=NATURAL, 3 SLOTS STILL OPEN
C 48 $=UPPER CASE, 49 %=LOWER, 50 &=NON-ITALICS(BDR), 51 @=ITALICS(BDI)
C 48 AND 49 NOT NEEDED NOW 6/75 48 &&=BDL (LIGHT-FACE)
C 52 #=RETURN TO PRIMITVE FONT, 53 <=OPEN, 54 >=FILLED. ('=55)
33 L=1
RC=0
IF(INP(KN).NE.KSLA)GO TO 333
IF(INP(KN+1).NE.KSLA)GO TO 133
C TYPE // TO PRINT A SINGLE SLASH. (NO SPACE BETWEEN!)
333 KN=KN+1
INP(KN)=KSLA
C SO TRAILING BLANKS ARE DELETED.
133 LL=1
RZ=0
ISET=IS
IF(R3.LT.1000)GO TO 233
RZ=1
R3=R3-1000.
RC=R3
C ADD 1000 TO POSITION (R3+1000) FOR CENTERING AT POS. R3.
233 RA=R3
C RA= ADDS UP TOTAL SPACE NEEDED
RX=0
C FOR SETLET
368 RN(IS+1)=16
RN(IS+3)=RA
C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
CC Y=39.6*RSTJ3
C RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
RN(IS+2)=R2
RN(IS+4)=R4
CALL NOZERO(R5)
RN(IS+5)=R5
IF(R5.GE.100)R5=R5-100
C >100 FOR TEXT IN ORCH SCORES TO GO IN ALL SEP. PARTS.
CKK KK=0
DO 364 J5=6,8
Z=0
DO 363 J4=1,4
361 IA=INP(L)
IF(IA.NE.KSLA)GO TO 365
C NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
IF(INP(L+1).NE.KSLA)GO TO 433
C TYPE // TO PRINT A SINGLE SLASH. (NO SPACE BETWEEN!)
CKK KK=KK+1
L=L+1
GO TO 365
433 J3=J4
DO 367 KA=J5,8
X=99.
DO 366 K=J3,4
Z=Z+X
366 X=X*100.0
RN(IS+KA)=Z
J3=1
367 Z=0
L=L+1
C L=CHARACTER COUNTER
GO TO 369
365 DO 362 J=1,30
IF(IA.NE.JALPHA(J))GO TO 362
N=35+J
C FOUND A SPECIAL CHARACTER.
K=N
IFNT=0
IF(N.NE.50)GO TO 39
IF(IA.NE.INP(L+1))GO TO 39
N=48
K=N
L=L+1
C TYPE && FOR LIGHT-FACE (BDL). PUSH PTR (L) ALONG 1 MORE.
GO TO 39
362 CONTINUE
38 N=10-(LA-INP(L))/536870912
C MAGIC NUMBER TO FIND LETTERS
IF(N.LT.10)N=N+7
K=N
IF(KFNT)IFNT=0
IF(N.LT.40)GO TO 39
N=N+28
KFNT=-1
C TO INITIALIZE AUTOMATIC LOWER CASE SYSTEM.
K=N-60
C K IS ACTUAL LETTER NUMB. (a=10, ETC.)
IFNT=-1
C LOWER CASE LETTERS ARE 60 .GT. UPPER. A=10, a=70, b=71, etc.
39 L=L+1
C BLANK=47 =99 WHEN NO MORE CHARS TO COME.
CALL SPACER(K,IFNT,RX,3.32)
C NUM↑↑=19.7/5.96 FOR BASIC SPACE PER LETTER.
C GET SPACE FOR THIS LETTER.
X=N
IF(J4.EQ.2)X=X*10000.
IF(J4.EQ.3)X=X*100.
IF(J4.EQ.1)X=X*1000000.
363 Z=Z+X
364 RN(IS+J5)=Z
369 RN(IS+9)=RX
RN(IS+10)=RZ
IF(RZ.EQ.0)KNT=KNT+1
IF(RC.NE.0)RN(IS+10)=RC
RC=0
C FOR CONTINUATION
RA=RA+RX*R5
IF(IA.EQ.KSLA)RA=RA+5
C SPACES GROUPS DIVIDED BY SLASHES
RX=0
IF(RZ.NE.0)GO TO 370
C SKIP IF P10=1, REQUIRED FOR CONTINUATION OF TEXT.
IF(IBLANK(IS,7))RZ=-2
C IF LAST CHAR IN P7 IS BLANK RESET WDCNT, GET RID OF P8 AND P9
IF(IBLANK(IS,6))RZ=-3
C ↑↑↑↑ LAST CHAR IN P6=BLNK ZAPS P7 IF NOT NEEDED. RZ=- CHANGES WORDCNT
370 RN(IS)=7+RZ
IS=IS+10+RZ
LL=LL+1
PWDS(ITEM+LL)=IS
C PUT IT IN THE PNTR ARRAY
RZ=1.
IF(IA.EQ.KSLA)RZ=0
IF(L.LT.KN)GO TO 368
C WAS ↑↑↑↑↑↑↑ .LE. 5/22/76
IF(KNT.GT.0)CALL SETLET
C GOES TO SETLET AUTOMATICALLY IF MORE THAN ONE SLASH FOUND.
IF(KFNT)IFNT=0
KFNT=0
INP(1)=0
C SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
END
C PACKS 4 CHARS/WD, 3 WDS/ITEM.
SUBROUTINE TYPE
COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
COMMON/ALF/INP(72),ML
TYPE 8005
ACCEPT 2114,INP
2114 FORMAT(72A1)
8005 FORMAT(' TYPE --'/)
CC** IF(JA.NE.16)CALL LNEND
C FOR 'SCORE' INPUT
END
SUBROUTINE SETLET
COMMON/SCM/V(76),RR4,NN,Y,LCNT,STAFF,JLIST(200),REND
C NOTE DIFFERENCE IN V ARRAY LNGTH 76+RR4+NN
COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
1 /PTR/PWDS(1)
CCC 1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(2000)
COMMON/FRMT/F78F(1),FA1(1),FA5(1),KK /ALF/INP(72),ML
COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
1 /POSI/STFP(0/7),J102,POS /LIMIT/LIMIT,ITEM,L,I,IX /XRN/RN(1)
1 /RINP/RPOS(2,450) /DPY/ST(4000),MEDIT,IGO
DIMENSION SU(320)
EQUIVALENCE (J5,JQ(3)),(ISET,RJQ(9)),(SU(1),ST(3600))
DATA DISP/0.0/
KK=L
C L=NUMBER OF ITEMS TYPED +1
M=1
IF(R4.EQ.0)KK=0
C =0 ALWAYS WANTS PAIRS OF NUMS.
RR4=R4
C GIVEN VERTICAL POS.
R4=20
RPOS(1,1)=0
DO 1 K=1,ITEM
IF(FINDIT(K))GO TO 1
C SKIPS NON-NOTES AND WRONG STAFF
M=M+1
RPOS(1,M)=RN(L+3)
1 CONTINUE
IF(M.EQ.1)RETURN
C M=1 MEANS NO NOTES ON THIS LINE
CALL DPYSET(3,SU,320)
CALL DPYBRT(6)
CC R6=1
POS=STFP(J2)
J5=1
CALL SORT2(RPOS,M)
K=2
22 IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
C ROUNDS OFF POSITION TO 2 DECI. PLACES
M=M-1
DO 20 J=K,M
20 RPOS(1,J)=RPOS(1,J+1)
C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
IF(M.LT.K)K=M
GO TO 22
302 FORMAT(17X'POS. FOR -- ',72A1/)
2 K=K+1
IF(K.LT.M)GO TO 22
DO 4 K=2,M
R3=RHORZ(RPOS(1,K))
CALL PNUM
J5=J5+1
4 IF(J5.EQ.10)J5=0
CALL DPYOUT(3)
CALL SETPOG(1)
RPOS(1,M+1)=200
NN2=1
J=1
JJ=1
IF(B)GO TO 30
C B IS JR IN 'WORDS' NEXT FOR READIN FILES WITH WORDS
READ(21,F78F)X,V
NN=76
GO TO 31
C FLAG FOR ALL BLANKS AT END OF LINE
30 MM=-1
K=JJ
300 IF(INP(K).NE.' ')MM=0
IF(INP(K).EQ.KSLA)GO TO 301
IF(K.EQ.72)GO TO 301
K=K+1
GO TO 300
301 IF(MM)GO TO 31
TYPE 302 ,(INP(LL),LL=JJ,K)
NN=NN2
NN2=NN2+1
ACCEPT F78F,V(NN),V(NN2)
IF(RR4.EQ.0)NN2=NN2+1
V(NN2)=0
JJ=K+1
IF(K.LT.72)GO TO 30
31 X=V(J)+1
DO 32 K=NN,1,-1
32 IF(V(K).NE.0)GO TO 320
320 IF(K.GT.KK)KK=-1
C NOW PAIRS OF NUMS WILL SET INDIV. VERT. POS.; SINGLE DON'T
3 K=X
A=RPOS(1,K)
B=RPOS(1,K+1)
RN(ISET+3)=A+(B-A)*(X-K)+DISP
C DISP IS DISPLACEMENT OF CURRENT LETTERS.
IF(KK.GT.0)GO TO 5
C NEXT FOR PAIRS OF NUMS.
RN(ISET+4)=V(J+1)
J=J+2
GO TO 6
C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
5 J=J+1
6 ISET=ISET+RN(ISET)+3
IF(RN(ISET).EQ.8)GO TO 6
C =8 MEANS MORE LETTERS TO COME.
X=V(J)+1
IF(X.GT.1)GO TO 3
C CAN'T PUT LETTER AT POS. 0 *********
K=ITEM+1
TYPE 321,K
321 FORMAT(' FIRST ITEM WAS ',I3)
END
SUBROUTINE PRESCN
C THIS SORTS OUT NEW INPUT FORMAT - CREATES OLD STYLE.
COMMON/SCX/RHY(4),JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
COMMON/SCN/LL,LR,LU,LD,LSL,LE,LC,LS,LF,LA,LI,LW
DATA LL/'L'/,LR/'R'/,LU/'U'/,LD/'D'/,LE/'E'/,LSL/'/'/
1,LC/'C'/,LS/'S'/,LF/'F'/,LA/'A'/,LI/'I'/,LW/'W'/
COMMON/ALF/INP(72),M/XRN/RN(1) /RINP/IR(900)
EQUIVALENCE (LCM,JALPHA),(LBL,JALPHA(12))
1,(LST,JALPHA(8)),(ISEMI,JALPHA(10)),(ICOL,JALPHA(9))
1,(IDOT,JALPHA(3))
C CHECK THIS EQUIV.↑↑↑↑
100 IF(ISM)5,55,555
C -1=PROCESS SOME MORE, 0=1ST TIME, 1=PUT OUT RHYTH
C !!!!! DON'T STOP IN THE MIDDLE!!! ISM MUST BE 0 FIRST TIME!!!!
55 JX=0
5 K=0
J=0
I=JX
JX=JX+72
1 K=K+1
M=INP(K)
15 IF(M.EQ.LBL)GO TO 1
IF(M.EQ.LCM)GO TO 1
C REMOVE BLANKS AND COMMAS
JN=0
IF(M.LT.'0')GO TO 677
IF(M.LE.'9')GO TO 2
677 MM=INP(K+1)
3 IF(M.EQ.'P')GO TO 8
IF(M.EQ.'O')GO TO 8
IF(M.LT.LA)GO TO 777
IF(M.GT.'G')GO TO 777
IF(MM.EQ.LL)GO TO 777
IF(MM.NE.LA)GO TO 8
C FINDS NOTES, PROX., AND ORDINARY, -- NOT 'BA' OR 'AL'
777 IF(M.NE.LR)GO TO 9
IF(MM.EQ.LE)JN=1
C CATCHES 'R' 'RI' 'REP'
GO TO 8
9 IF(M.EQ.LSL)GO TO 8
IF(M.EQ.ISEMI)GO TO 8
IF(M.EQ.LST)GO TO 8
IF(M.EQ.ICOL)GO TO 8
JN=-1
8 J=J+1
INP(J)=M
IF(M.EQ.'X')JN=1
C PICKS UP 4X ETC. FOR BOTH NOTES AND RHYTH.
IF(JN.LE.0)GO TO 13
C PUTS 'REP' INTO RHYTH ALSO
I=I+1
IR(I)=M
13 IF(M.EQ.LSL)GO TO 4
IF(M.EQ.ISEMI)GO TO 4
IF(M.EQ.LST)GO TO 4
K=K+1
M=INP(K)
GO TO 8
4 IF(JN.NE.0)GO TO 7
I=I+1
IR(I)=M
7 IF(M.EQ.LSL)GO TO 1
IF(M.EQ.ISEMI)GO TO 11
IF(M.EQ.LST)GO TO 6
2 I=I+1
IR(I)=M
K=K+1
M=INP(K)
IF(M.EQ.IDOT)GO TO 2
IF(M.LT.'0')GO TO 15
IF(M.LE.'9')GO TO 2
C NO BLANK NEEDED AFTER RHYTH.( /4.AS3/8/ ETC.)
GO TO 15
11 IF(IR(I).NE.ISEMI)IR(I)=ISEMI
ISM=-1
RETURN
C WE'LL COME BACK FOR MORE.
6 IF(IR(I).NE.LST)IR(I)=LST
JX=0
ISM=1
C AFTER THIS WE USE RHYTJ DATA.
RETURN
555 DO 12 K=1,72
M=IR(K+JX)
INP(K)=M
IF(M.EQ.ISEMI)GO TO 10
C MORE THAN ONE LINE
12 IF(M.EQ.LST)GO TO 14
10 JX=JX+72
C MOVE TO THE NEXT 'LINE'
RETURN
14 ISM=0
END
FUNCTION IBLANK(IS,N)
COMMON /XRN/RN(2000)
IBLANK=0
IF(AMOD(RN(IS+N),100.0).EQ.99.0)IBLANK=-1
END